Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/regmax.000/regmax.bas

BASIC Source File | 1995-12-22 | 17KB | 508 lines

'   ******************************************************
'   //THIS MODULE (REGMAX.BAS) IS DESIGNED TO BE INCLUDED IN YOUR
'   //OWN PROJECT, AND CONTAINS ALL THE GBLIB2 FUNCTIONS
'   //NECESSARY TO WRITE AND READ REGISTRATION DATA.
'   //IT MUST BE USED IN CONJUNCTION WITH GBLIB2.EXE.
'   //REGMAX.EXE, REGMAX.BAS (c)1995 Gordon Bamber//
'   ******************************************************

Option Explicit
'   /* Modified 11/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */
'   /* Modified 02/01/95 [GB] */
'   /* Modified 31/12/94 [GB] */
'   /* Created 31/12/94 [GB] */


'   //WIN31 API Function to bar accidents in development mode!//
'   //Alised so as not to clash with other declares in this project//
Declare Function FindIt Lib "User" Alias "FindWindow" (ByVal lpClassName As String, ByVal lpWindowName As String) As Integer

'   //*************** Declares for the API in GBLIB2.EXE *************//

'   //This function is a crude string -> number algorithm//
'   //It can be used to make a checksum of the registration information//
Declare Function MakeAKey Lib "GBLIB2.EXE" (ByVal AString As String) As Long
Declare Sub Encryptit Lib "GBLIB2.EXE" (ByVal AString As String, AStringLen As Integer)

'   //The next three functions must NOT be used in development mode//
'   //on this project, because they are designed to//
'   //modify this application's EXE file directly, and until it has been//
'   //compiled, there is no EXE file to modify!
Declare Function WriteRegData Lib "GBLIB2.EXE" (ByVal sz_Name As String, ByVal sz_Org As String, ByVal sz_EXEPath As String, ByVal MyPhrase As String) As Integer
Declare Function ReadRegData Lib "GBLIB2.EXE" (ByVal sz_EXEPath As String, ByVal sz_Name As String, ByVal sz_Org As String, ByVal YMD As String, NameLen As Integer, OrgLen As Integer) As Integer
Declare Function CheckRegistration Lib "GBLIB2.EXE" (ByVal sz_EXEPath As String) As Integer

Declare Function WriteRegDataToINI Lib "GBLIB2.EXE" (ByVal sz_Name As String, ByVal sz_Org As String, ByVal sz_EXEPath As String) As Integer
Declare Function ReadRegDataFromINI Lib "GBLIB2.EXE" (ByVal sz_EXEPath As String, ByVal sz_Name As String, ByVal sz_Org As String, NameLen As Integer, OrgLen As Integer) As Integer

'   //These Subs simply show information//
Declare Sub ShowWinDir Lib "GBLIB2.EXE" ()
Declare Sub ShowSysDir Lib "GBLIB2.EXE" ()

'   //******************************************************************//

'   //***** Data constants *****//
Global Const MONTHSTRING = "JanFebMarAprMayJunJulAugSepOctNovDec"

'   //############# ALTER THIS IF NEEDED ##############//
Global Const EXPIRYDAYS = 31'   //No. of days to expiry//
'   //############# ALTER THIS IF NEEDED ##############//

'   //******************************************************************//

'   //***** Global Registration variables *****//
Global sz_EXEPath As String'    //The full path to a VB3 Executable//

Global EXPIRED As Integer'  //True/False. Set in GetDataFromEXE//
'                           //depends on constant EXPIRYDAYS//

Global USERNAME As String'  //33 characters maximum//
Global USERORG As String'   //33 characters maximum//
Global BRANDDATE As String' //4 Characters//

Global BRANDYEAR As Integer'    //Range 95->//
Global BRANDMONTH As Integer'   //Range 1-12//
Global BRANDDAY As Integer'     //Range 1-31//

'   //LONG Values depend on whether MSFINX.DLL is available//
Global LONGBRANDDATE As Long'   //Date registered/branded//
Global LONGTODAYSDATE As Long'  //System date//

Global INI_USERNAME As String'  //33 characters maximum//
Global INI_USERORG As String'   //33 characters maximum//

'   //******************************************************************//

Function Check_ErrorString (i_Errorcode As Integer) As String

'   /* Modified 15/01/95 [GB] */
'   /* Created 15/01/95 [GB] */
Dim msg As String
Select Case i_Errorcode
Case 0
    msg = "OK"
Case 1
    msg = "Name= entry does not match registration details"
Case 2
    msg = "Organisation= entry does not match registration details"
Case 3
    msg = "Both registration entries in the INI file have been altered"

'   // Value > 8192 means that the EXE-file is unbranded/corrupt//
Case 8303
    msg = "Registration details in EXE file are absent. INI file is present."

'   //Value > 16384 means that the INI-File is corrupt/absent//
Case 16389
    msg = "EXE is Unbranded. Name entry Name= is blank. Organisation= entry is correct."
Case 16402
    msg = "EXE is Unbranded. Name entry Name= is correct. Organisation= entry is blank."
Case 16403
    msg = "EXE is Unbranded. INI entry Name= is blank. Organisation= entry is incorrect."
Case 16415
    msg = "EXE is Unbranded. INI entry Organisation= is blank. Name= entry is incorrect."
Case 16416
    msg = "EXE is Unbranded. INI entry Name= is absent. Organisation= entry is incorrect."
Case 16419
    msg = "EXE is Unbranded. INI entry Name= is blank. Organisation= entry is blank."
Case 16426
    msg = "EXE is Unbranded. INI entry Name= is correct. Organisation= entry is missing."
Case 16437
    msg = "EXE is Unbranded. INI entry Name= is incorrect. Organisation= entry is missing."
Case 16445
    msg = "EXE is Unbranded. INI file is missing."
Case 16454
    msg = "This is a totally unregistered file."
Case Else
    msg = "Unknown error. (Code #" & Format$(i_Errorcode) & ")"
End Select
Check_ErrorString = msg

End Function

Sub DevMsg ()

'   /* Modified 11/01/95 [GB] */
'   /* Modified 31/12/94 [GB] */
'   /* Created 31/12/94 [GB] */

'   //This message is shown if ISVBRUNNING returns true//

Dim msg As String
msg = "You are working in Development Mode" & Chr$(10) & Chr$(10)
msg = msg & "I cannot therefore read or write data" & Chr$(10)
msg = msg & "to or from this application," & Chr$(10)
msg = msg & "because you havn't compiled it yet!" & Chr$(10)
msg = msg & "Compile this application, and run it" & Chr$(10)
msg = msg & "outside of the Visual Basic IDE entirely."
MsgBox msg, 48, "REGMAX - Get / PutDataIntoEXE"
End Sub

Sub DisplayRegInfo ()
'   /* Modified 14/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */
'   /* Created 06/01/95 [GB] */

Dim i_EXERetVal As Integer
Dim i_INIRetVal As Integer
i_EXERetVal = GetDataFromEXE()' //Sets USERNAME and USERORG//
i_INIRetVal = GetDataFromINI()' //Sets INI_USERNAME and INI_USERORG//
Dim msg As String
msg = ""


If (i_INIRetVal + i_EXERetVal) > 0 Then
    msg = msg & "This software is Unregistered."
Else
    '   //Display embedded registration information//
    msg = msg & "This software is registered" & Chr$(10)
    msg = msg & "to: " & USERNAME & Chr$(10)
    msg = msg & "of: " & USERORG
End If
MsgBox msg, 64 + 4096, "Registration Information"

End Sub

Function DisplayRegInfoFromINI () As Integer

'   /* Modified 14/01/95 [GB] */
'   /* Created 14/01/95 [GB] */

Dim i_RetVal As Integer
i_RetVal = GetDataFromINI()
DisplayRegInfoFromINI = i_RetVal
Dim msg As String

If i_RetVal > 0 Then
    msg = "This is an Unregistered INI."
Else
    '   //Display embedded registration information//
    msg = "This software is registered" & Chr$(10)
    msg = msg & "to: " & INI_USERNAME & Chr$(10)
    msg = msg & "of: " & INI_USERORG
End If
MsgBox msg, 64 + 4096, "INI Registration Information"

End Function

Sub DisplayRegInfoWithExpiry ()
'   /* Modified 14/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */
'   /* Created 06/01/95 [GB] */

Dim i_RetVal As Integer
i_RetVal = GetDataFromEXE()

Dim msg As String
If i_RetVal > 0 Then
    msg = "This software is Unregistered."
Else
    '   //Display embedded registration information//
    msg = "This software was registered" & Chr$(10)
    msg = msg & "to: " & USERNAME & Chr$(10)
    msg = msg & "of: " & USERORG

    '   //Optional line//
    msg = msg & Chr$(10) & "on: " & BRANDDATE

    '   //EXPIRED is set True/False by GetDataFromEXE//
    '   //EXPIRYDAYS is a Global Const set in (declarations) //
    If EXPIRED <> False Then
    msg = msg & Chr$(10) & Chr$(10) & "* YOUR " & Format$(EXPIRYDAYS) & "-DAY EVALUATION" & Chr$(10)
    msg = msg & "PERIOD HAS NOW EXPIRED."
    '   //Kill Application from the Hard Disk here//
    End If' //of If EXPIRED//
End If' //of If UNLICENSED//

MsgBox msg, 64 + 4096, "Registration Information"

End Sub

Function Get_sz_CurrentEXEPath () As String

'   /* Modified 14/01/95 [GB] */
'   /* Created 14/01/95 [GB] */

Dim sz_TempPath As String

'   //Get the full path and filename of this application//
sz_TempPath = App.Path
If Right$(sz_TempPath, 1) <> "\" Then sz_TempPath = sz_TempPath & "\"
sz_TempPath = sz_TempPath & App.EXEName & ".EXE"

Get_sz_CurrentEXEPath = sz_TempPath
End Function

Function GetDataFromEXE () As Integer

On Error GoTo ERR_GDFE
'   /* Modified 14/01/95 [GB] */
'   /* Modified 11/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */
'   /* Modified 02/01/95 [GB] */
'   /* Modified 30/12/94 [GB] */
'   /* Created 30/12/94 [GB] */

'   //Quit out in development mode//
If ISVBRUNNING() <> 0 Then
    DevMsg
    Exit Function
End If

Dim i_RetValue As Integer
Dim NameLen As Integer
Dim OrgLen As Integer
Dim TUserName As String
Dim TUserOrg As String
Dim YMD As String

'   //Initialise//
EXPIRED = False
BRANDDATE = "UNKNOWN"
LONGBRANDDATE = 0
LONGTODAYSDATE = 0

'******** REM out next section if reading an external program **********

'***********************************************************************

'   //You MUST initialise the strings to this length or VB cannot//
'   //cope with passing strings to/from the GBLIB2 API//
TUserName = String$(42, 0)
TUserOrg = String$(34, 0)
YMD = String$(4, 0)

'   //Read the Information from the EXE//
i_RetValue = ReadRegData(sz_EXEPath, TUserName, TUserOrg, YMD, NameLen, OrgLen)
'   //Return value is Zero if sz_EXEPath is branded OK, otherwise 1//
'   //TUserName(NameLen+1) is ASCII(0)
'   //TUserOrg(OrgLen+1) is ASCII(0)

'   //If the EXE is 'virgin' then i_RetVal=1
'     and USERNAME and USERORG = 'UNLICENSED' //

'   //Trim to the last useable character//
USERNAME = Left$(TUserName, NameLen)
USERORG = Left$(TUserOrg, OrgLen)

GetDataFromEXE = i_RetValue
'   //Now process the DATE information//
'   //If the EXE is virgin then YMD is all spaces or ASCII 0//
If Left$(YMD, 1) = " " Then Exit Function
If Left$(YMD, 1) = Chr$(0) Then Exit Function

'   //YMD = The Year-Month-Date in ASCII codes//
'   //Here I unpack the YMD data into the 'English' form of dd mmmm yyyy//

'   //1) Day//
BRANDDAY = Asc(Mid$(YMD, 3, 1))
BRANDDATE = Format$(BRANDDAY, "#0")

'   //2) Month//
BRANDMONTH = Asc(Mid$(YMD, 2, 1))
BRANDDATE = BRANDDATE & " " & Mid$(MONTHSTRING, (BRANDMONTH) * 3 - 2, 3)

'   //3) Year//
'   //NOTE it is returned as (YY+108)//
BRANDYEAR = Asc(Left$(YMD, 1)) - 108
BRANDDATE = BRANDDATE & " 19" & Format$(BRANDYEAR, "00")

On Error GoTo NO_MSFINX_DLL
'   //Make up numbers (that vary in days) for expiry comparisons//
'   //Use financial functions if available//
'   //Remember to include the financial DLLs on your distribution disk(s)//
LONGBRANDDATE = DateSerial(BRANDYEAR, BRANDMONTH, BRANDDAY)
LONGTODAYSDATE = DateSerial(Year(Now), Month(Now), Day(Now))
If Abs(LONGTODAYSDATE - LONGBRANDDATE) > EXPIRYDAYS Then EXPIRED = True
'   //All OK//
Exit Function


'   //DateSerial function has caused an error, so come here//
GDFE_OUT:
'   //Resume here if VB3 Financial DLLs (e.g. MSFINX.DLL) are absent//
LONGBRANDDATE = Val(Format$(BRANDYEAR, "00") & Format$(BRANDMONTH, "00") & Format$(BRANDDAY, "00"))
LONGTODAYSDATE = Val(Format$(Now, "yymmdd"))
'   //This will not work so well across month boundaries...//
If Abs(LONGTODAYSDATE - LONGBRANDDATE) > EXPIRYDAYS Then EXPIRED = True

'   //Resume here from a fatal error//
GDFE_ERROR:
Exit Function


NO_MSFINX_DLL:
'   //Triggered ErrorHandler//
'   //Come here if VB3 Financial DLL is absent, and triggers an error//
Resume GDFE_OUT

ERR_GDFE:
'   //Fatal ErrorHandler//
MsgBox "Unable to fetch registration data", 48, "Sub GetDataFromEXE"
Resume GDFE_ERROR
End Function

Function GetDataFromINI () As Integer


'   /* Modified 14/01/95 [GB] */
'   /* Created 14/01/95 [GB] */

Dim TUserName As String
Dim TUserOrg As String
Dim i_RetValue As Integer
Dim NameLen As Integer
Dim OrgLen As Integer


'   //You MUST initialise the strings to this length or VB cannot//
'   //cope with passing strings to/from the GBLIB2 API//
TUserName = String$(42, 0)
TUserOrg = String$(34, 0)

'   //Read the Information from the INI//
i_RetValue = ReadRegDataFromINI(sz_EXEPath, TUserName, TUserOrg, NameLen, OrgLen)
GetDataFromINI = i_RetValue
'   //Return value is Zero if sz_EXEPath is branded OK, otherwise 1 or more//
'   //i_RetVal=10 - Not a VB V3.0 program//
'   //i_RetVal=11 - A VB V2.0 program//
'   //i_RetVal=12 - A TPW program//
'   //i_RetVal=13 - A 32-Bit program//


'   //TUserName(NameLen+1) is ASCII(0)
'   //TUserOrg(OrgLen+1) is ASCII(0)

'   //If the INI is absent then i_RetVal=1
'     and USERNAME and USERORG = 'UNLICENSED' //

'   //Trim to the last useable character//
INI_USERNAME = Left$(TUserName, NameLen)
INI_USERORG = Left$(TUserOrg, OrgLen)

End Function

Function IsUnRegistered () As Integer


'   /* Modified 14/01/95 [GB] */
'   /* Created 14/01/95 [GB] */

Dim i_RetVal As Integer


i_RetVal = GetDataFromEXE()
i_RetVal = GetDataFromINI()
i_RetVal = CheckRegistration(sz_EXEPath)
IsUnRegistered = i_RetVal


End Function

Function ISVBRUNNING () As Integer
'   /* Modified 06/01/95 [GB] */

'   /* Modified 31/12/94 [GB] */
'   /* Created 31/12/94 [GB] */

'   //Debugging line - Ignore//
If LCase(Command$) = "debug" Then
    ISVBRUNNING = 0
    Exit Function
End If

'   //Simple test to see if VB is in development mode//
If FindIt("wndclass_desked_gsk", "Microsoft Visual Basic [run]") > 0 Then
    ISVBRUNNING = 1
Else
    ISVBRUNNING = 0
End If
End Function

Function PutDataIntoEXE (AName As String, AnOrganisation As String, sz_Key As String) As Integer
'   /* Modified 14/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */

'   /* Modified 31/12/94 [GB] */
'   /* Created 31/12/94 [GB] */

'   //OPTIONAL//
'   //Quit if running in development mode//
 If ISVBRUNNING() <> 0 Then
     DevMsg
     Exit Function
 End If

Dim i_RetValue As Integer

'   //OPTIONAL//

'   //NOTE: sz_EXEPath could be set to any VB3 program, not//
'   //just this one.

'   //Do the deed. Note that AName and AnOrganisation will be truncated//
'   //if either are over 33 characters//

i_RetValue = WriteRegData(AName, AnOrganisation, sz_EXEPath, sz_Key)
PutDataIntoEXE = i_RetValue

'   //Return value is zero for success/
'   //Return value is 1 if either item has been truncated//
'   //Return value is 2 if USERNAME was an empty string//
'   //Return value is 3 if USERORG was an empty string//
'   //Return value is 99 if sz_Key was bad//


End Function

Function PutDataIntoINI (AName As String, AnOrganisation As String) As Integer

'   /* Modified 14/01/95 [GB] */
'   /* Created 14/01/95 [GB] */

'   //OPTIONAL//
'   //Quit if running in development mode//
If ISVBRUNNING() <> 0 Then
    DevMsg
    Exit Function
End If

Dim i_RetValue As Integer

'   //NOTE: sz_EXEPath could be set to any VB3 program, not//
'   //just this one.

'   //Do the deed. Note that AName and AnOrganisation will be truncated//
'   //if either are over 33 characters//

'   //Write to/Create and write to (APP.EXEName).INI file in WINDOWS directory//
i_RetValue = WriteRegDataToINI(AName, AnOrganisation, sz_EXEPath)
'   //Return value is zero for success/
'   //Return value is 1 if USERNAME was an empty string//
'   //Return value is 2 if USERORG was an empty string//
'   //Return value is 3 if unable to write User= entry in the INIFile//
'   //Return value is 4 if unable to write Organisation= entry in the INIFile//
'   //Return value is 99 if sz_Key was bad//
PutDataIntoINI = i_RetValue
End Function

Sub ShowSplash ()

'   /* Modified 14/01/95 [GB] */
'   /* Modified 06/01/95 [GB] */
'   /* Created 06/01/95 [GB] */
Dim i_RetVal As Integer

i_RetVal = GetDataFromEXE()

'   //Is it a 'virgin' EXE? //
If USERNAME = "UNLICENSED" Then
    MsgBox "This is an unlicensed copy of " & App.EXEName, 64 + 4096, App.EXEName & " Registration Information"
Else
'   //Display embedded registration information//
    DisplayRegInfo
End If
End Sub